home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / emerald / emrldsys.lha / Language / Compiler / sugar.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-08-16  |  20.7 KB  |  757 lines
  1. /*
  2.  * @(#)sugar.c    1.9  2/23/90
  3.  */
  4. #include "assert.h"
  5. #include "error.h"
  6. #include "scan.h"
  7. #include "nodes.h"
  8. #include "symbols.h"
  9. #include "MyParser.h"
  10. #include "semantics.h"
  11. #include "system.h"
  12. #include "builtins.h"
  13. #include "flags.h"
  14. #include "sequence.h"
  15. #include "opNames.h"
  16.  
  17. #define NN ((NodePtr) NULL)
  18.  
  19. extern NodePtr buildString();
  20. #define BSR(P,I) buildSymbol(P_SYMREF, P, I)
  21. #define BSD(P,I) buildSymbol(P_SYMDEF, P, I)
  22. #define BON(P,I) buildOpName(P, I)
  23.  
  24. static NodePtr buildS(), _buildS(), buildSignature(), _buildSignature(), 
  25.            buildBlock(), _buildBlock();
  26.  
  27. static NodePtr builtinPAT, builtinBoolean, builtinAny, builtinInteger,
  28.   builtinNode;
  29.  
  30. NodePtr copySig(p)
  31. register NodePtr p;
  32. {
  33.   register NodePtr result;
  34.   register int i;
  35.   if (ISTOKEN(p)) return(p);
  36.   result = F_NewNode(p->tag, p->nChildren-p->firstChild);
  37.   result->nChildren = p->nChildren;
  38.   for (i = 0; i < p->firstChild; i++) {
  39.     result->b.children[i] = p->b.children[i];
  40.   }
  41.   if (p->tag == P_PARAM) {
  42.     result->b.param.sym = copySig(p->b.param.sym);
  43.     result->b.param.type = p->b.param.type;
  44.     result->b.param.constraint = p->b.param.constraint;
  45.   } else {
  46.     for (i = p->firstChild; i < p->nChildren; i++) {
  47.       result->b.children[i] = copySig(p->b.children[i]);
  48.     }
  49.   }
  50.   return(result);
  51. }
  52.  
  53. void init_Sugar()
  54. {
  55.   builtinPAT = Construct(P_BUILTINLIT, 0);
  56.   builtinPAT->b.builtinlit.whichType = KSIGNATURE;
  57.   builtinBoolean = Construct(P_BUILTINLIT, 0);
  58.   builtinBoolean->b.builtinlit.whichType = KBOOLEAN;
  59.   builtinAny = Construct(P_BUILTINLIT, 0);
  60.   builtinAny->b.builtinlit.whichType = KANY;
  61.   builtinInteger = Construct(P_BUILTINLIT, 0);
  62.   builtinInteger->b.builtinlit.whichType = KINTEGER;
  63.   builtinNode = Construct(P_BUILTINLIT, 0);
  64.   builtinNode->b.builtinlit.whichType = KNODE;
  65. }
  66.  
  67. static NodePtr buildIntegerLiteral(n)
  68. int n;
  69. {
  70.   char *string;
  71.   NodePtr result;
  72.   string = (char *) malloc(10);
  73.   (void) sprintf(string, "%d", n);
  74.   result = Construct(P_INTLIT, 0);
  75.   result->b.intlit.string = string;
  76.   return(result);
  77. }
  78.  
  79. NodePtr buildComplicatedSymbol(tag, prefix, ident, suffix)
  80. Tag tag;
  81. char *prefix, *suffix;
  82. Ident ident;
  83. {
  84.   register char *buf;
  85.   register char *name;
  86.   register NodePtr p;
  87.   
  88.   p = Construct(tag, 0);
  89.   name = ident == 0 ? "" : Ident_Name(ident);
  90.   buf = (char *) 
  91.     malloc((unsigned)(strlen(prefix)+strlen(suffix)+strlen(name)+10));
  92.   (void) sprintf(buf, "%s%s%s", prefix, name, suffix);
  93.   p->b.symdef.ident = Ident_Lookup(buf, strlen(buf));
  94.   free(buf);
  95.   return(p);
  96. }
  97.  
  98. extern Boolean opNamesResolved;
  99.  
  100. NodePtr buildOpName(prefix, i)
  101. char *prefix;
  102. Ident i;
  103. {
  104.   register char *old, *new;
  105.   register NodePtr p;
  106.   
  107.   p = Construct(P_OPNAME, 0);
  108.   if (i <= 0) old = "";
  109.   else old = Ident_Name(i);
  110.   new = (char *) malloc((unsigned)(strlen(old)+strlen(prefix)+1));
  111.   (void) strcpy(new, prefix);
  112.   (void) strcat(new, old);
  113.   p->b.opname.ident = Ident_Lookup(new, strlen(new));
  114.   if (opNamesResolved) p->b.opname.id = ON_Translate(new);
  115.   Free(new);
  116.   return(p);
  117. }
  118.  
  119. static NodePtr _buildInvocation(target, opName, n, args)
  120. NodePtr target, opName;
  121. register NodePtr *args;
  122. int n;
  123. {
  124.   register int i;
  125.   register NodePtr params;
  126.   if (n == 0) params = NN;
  127.   else {
  128.     params = F_NewNode(T_SEQUENCE, n);
  129.     params->nChildren = n;
  130.     for (i = 0; i < n; i++) {
  131.       params->b.children[i] = Construct(P_ARG, 1, args[i]);
  132.     }
  133.   }
  134.   return(Construct(P_INVOC, 3, target, opName, params));
  135. }
  136.  
  137. /*VARARGS3*/
  138. static NodePtr buildInvocation(target, opName, n, firstParameter)
  139. NodePtr target, opName, firstParameter;
  140. int n;
  141. {
  142.   return _buildInvocation(target, opName, n, &firstParameter);
  143. }
  144.  
  145. NodePtr buildSymbol(tag, prefix, index)
  146. Tag tag;
  147. char *prefix;
  148. int index;
  149. {
  150.   register char *buf;
  151.   register NodePtr p;
  152.   
  153.   p = Construct(tag, 0);
  154.   buf = (char *) malloc((unsigned)(strlen(prefix)+20));
  155.   if (index < 0) (void) strcpy(buf, prefix);
  156.   else (void) sprintf(buf, "%s__%d", prefix, index);
  157.   p->b.symdef.ident = Ident_Lookup(buf, strlen(buf));
  158.   free(buf);
  159.   return(p);
  160. }
  161.  
  162. void removeSugar(fNodePtr)
  163. NodePtr *fNodePtr;
  164. {
  165.   NodePtr instanceAT, opSigSeq, typeO, instanceO, od, s1, s2, sig,
  166.       monitorO, varDecls, opDecls, exportSeq, iAT, block;
  167.   int numFields;
  168.   register NodePtr thisField;
  169.   NodePtr *argvec, createSig;
  170.   register NodePtr p, r, l, result = NN;
  171.   NodePtr name, args, assignedValue;
  172.   register int i;
  173.   Boolean isImmutable, isSugared;
  174.   int factor;
  175.  
  176.   p = *fNodePtr;
  177.   if (p == NN) {
  178.     return;
  179.   } else if ((int)p < 0x200) {
  180.     /* it is probably an input token */
  181.     return;
  182.   } else {
  183.     nextLineNumber = p->lineNumber;    
  184.     switch (p->tag) {
  185.       case P_COMP:
  186.     if (!bflag) {
  187.       r = Construct(P_INVOC, 3, 
  188.         builtinNode,
  189.         buildOpName("getStdin", -1),
  190.         NN);
  191.       r = Construct(P_CONSTDECL, 3,
  192.         buildSymbol(P_SYMDEF, "stdin", -1),
  193.         NN,
  194.         r);
  195.       Sequence_AddFirst(&p->b.comp.consts, r);
  196.       r = Construct(P_INVOC, 3, 
  197.         builtinNode,
  198.         buildOpName("getStdout", -1),
  199.         NN);
  200.       r = Construct(P_CONSTDECL, 3,
  201.         buildSymbol(P_SYMDEF, "stdout", -1),
  202.         NN,
  203.         r);
  204.       Sequence_AddFirst(&p->b.comp.consts, r);
  205.     }
  206.     break;
  207.       case P_ASSIGNSTAT:
  208.     assert(isASequence(p->b.assignstat.left));
  209.     assert(isASequence(p->b.assignstat.right));
  210.     isSugared = FALSE;
  211.     Sequence_For(l, p->b.assignstat.left)
  212.       if (l->tag == P_SUBSCRIPT || l->tag == P_FIELDSEL) isSugared = TRUE;
  213.     Sequence_Next
  214.     if (isSugared &&
  215.         (p->b.assignstat.left->nChildren != 1 ||
  216.          p->b.assignstat.right->nChildren != 1)) {
  217.       BeginErrorMessage(p->b.assignstat.left);
  218.       ErrorWrite("Illegal sugared assignment");
  219.       EndErrorMessage();
  220.       break;
  221.     } else if (!isSugared) {
  222.       p->b.assignstat.op = OASSIGN;
  223.       break;
  224.     }
  225.     /*
  226.      * We only get here if we have a sugared assign with one thing on
  227.      * the left.
  228.      */
  229.     r = p->b.assignstat.left->b.children[0];
  230.     /*
  231.      * Now r points to the expression that we are assigning
  232.      * to.
  233.      */
  234.     assignedValue = 
  235.       Construct(P_ARG, 1, p->b.assignstat.right->b.children[0]);
  236.     Free(p->b.assignstat.right);
  237.     Free(p->b.assignstat.left);
  238.     if (r->tag == P_SUBSCRIPT) {
  239.       name = BON("setelement", -1);
  240.       args = r->b.subscript.exp;
  241.       Sequence_Add(&args, assignedValue);
  242.       result = Construct(P_INVOC, 3, r->b.subscript.target,
  243.           name, args);
  244.     } else if (r->tag == P_FIELDSEL) {
  245.       name = BON("set", r->b.fieldsel.fieldref->b.fieldref.ident);
  246.       args = Construct(T_SEQUENCE, 1, assignedValue);
  247.       result = Construct(P_INVOC, 3, r->b.fieldsel.target,
  248.           name, args);
  249.     } else {
  250.       assert(FALSE);
  251.     }
  252.     Free(r);
  253.     p->b.assignstat.left = NULL;
  254.     p->b.assignstat.op = OASSIGN;
  255.     p->b.assignstat.right = Construct(T_SEQUENCE, 1, result);
  256.     break;
  257.       case P_FIELDSEL:
  258.     name = BON("get", p->b.fieldsel.fieldref->b.fieldref.ident);
  259.     args = NN;
  260.     result = Construct(P_INVOC, 3, p->b.fieldsel.target, name, args);
  261.     Free(p);
  262.     *fNodePtr = result;
  263.     break;
  264.       case P_SUBSCRIPT:
  265.     name = BON("getelement", -1);
  266.     args = p->b.subscript.exp;
  267.     result = Construct(P_INVOC, 3, p->b.subscript.target, name, args);
  268.     Free(p);
  269.     *fNodePtr = result;
  270.     break;
  271.       case P_ENUMLIT:
  272.     typeO = F_NewNode(P_OBLIT, 10);
  273.     typeO->nChildren += 10;
  274.     typeO->b.oblit.sfname = buildString(currentFileName);
  275.     typeO->b.oblit.name = BSD("enum", 0);
  276.     assert(p->b.enumlit.syms->tag == T_SEQUENCE);
  277.     numFields = p->b.enumlit.syms->nChildren;
  278.     argvec = (NodePtr *) malloc((unsigned)(sizeof(NodePtr)*(numFields+4)));
  279.     argvec[0] = BON("getsignature", -1);
  280.     argvec[1] = BON("create", -1);
  281.     argvec[2] = BON("first", -1);
  282.     argvec[3] = BON("last", -1);
  283.     for (i = 0; i < numFields; i++) {
  284.       thisField = p->b.enumlit.syms->b.children[i];
  285.       assert(thisField->tag == P_SYMDEF);
  286.       argvec[4+i] = BON(Ident_Name(thisField->b.symdef.ident), -1);
  287.     }
  288.     typeO->b.oblit.export =
  289.       Construct(P_EXPORT, 2, _buildS(4+numFields, argvec), NN);
  290.     free((char *)argvec);
  291.     /*
  292.     * Build the abstract type for the instances.
  293.     */
  294.     opSigSeq = F_NewNode(T_SEQUENCE, 9);
  295.     opSigSeq->nChildren = 9;
  296.     iAT = BSR("instanceAT", -1);
  297.     opSigSeq->b.children[0] = buildSignature(
  298.       BON("=", -1), iAT, NN, builtinBoolean, NN);
  299.     opSigSeq->b.children[1] = buildSignature(
  300.       BON("!=", -1), iAT, NN, builtinBoolean, NN);
  301.     opSigSeq->b.children[2] = buildSignature(
  302.       BON("<", -1), iAT, NN, builtinBoolean, NN);
  303.     opSigSeq->b.children[3] = buildSignature(
  304.       BON("<=", -1), iAT, NN, builtinBoolean, NN);
  305.     opSigSeq->b.children[4] = buildSignature(
  306.       BON(">", -1), iAT, NN, builtinBoolean, NN);
  307.     opSigSeq->b.children[5] = buildSignature(
  308.       BON(">=", -1), iAT, NN, builtinBoolean, NN);
  309.     opSigSeq->b.children[6] = buildSignature(
  310.       BON("succ", -1), NN, iAT, NN);
  311.     opSigSeq->b.children[7] = buildSignature(
  312.       BON("pred", -1), NN, iAT, NN);
  313.     opSigSeq->b.children[8] = buildSignature(
  314.       BON("ord", -1), NN, builtinInteger, NN);
  315.     for (i = 0; i < 9; i++) {
  316.       opSigSeq->b.children[i]->b.opsig.isFunction = TRUE;
  317.     }
  318.     instanceAT = Construct(P_ATLIT, 4,
  319.       buildString(currentFileName),
  320.       NULL,
  321.       BSD("instanceAT", -1), 
  322.       opSigSeq);
  323.     typeO->b.oblit.decls = buildS(1,
  324.       Construct(P_CONSTDECL, 3, BSD("instanceAT", -1), NN, instanceAT));
  325.     typeO->b.oblit.monitor = NN;
  326. /* Build the operations on the type. */
  327. /* build the getSignature operation on the type. */
  328.     typeO->b.oblit.ops = F_NewNode(T_SEQUENCE, 4+numFields);
  329.     typeO->b.oblit.ops->nChildren = 4+numFields;
  330.     od = Construct(P_OPDEF, 2, 
  331.       buildSignature(BON("getsignature", -1), NN, builtinPAT, NN),
  332.       buildBlock(BSR("r", 0), BSR("instanceAT", -1), NN));
  333.     od->b.opdef.sig->b.opsig.isFunction = TRUE;
  334.     typeO->b.oblit.ops->b.children[0] = od;
  335. /* build the creation signature */
  336.     createSig = buildSignature(BON("create", -1), builtinInteger, NN, BSR("instanceAT", -1), NN);
  337.     createSig->b.opsig.isFunction = TRUE;
  338. /* build the instanceO. */
  339.     instanceO = F_NewNode(P_OBLIT, 10);
  340.     instanceO->nChildren += 10;
  341.     instanceO->b.oblit.sfname = buildString(currentFileName);
  342.     instanceO->b.oblit.name = BSD("anEnum", 1);
  343.     exportSeq = Construct(T_SEQUENCE, 9, BON("=", -1), BON("!=", -1),
  344.       BON("<", -1), BON("<=", -1), BON(">", -1), BON(">=", -1),
  345.       BON("succ", -1), BON("pred", -1), BON("ord", -1));
  346.     instanceO->b.oblit.export = Construct(P_EXPORT, 2, exportSeq, NN);
  347.     instanceO->b.oblit.decls = NN;
  348.     monitorO = F_NewNode(P_MONITOR, 4);
  349.     monitorO->nChildren += 4;
  350.     varDecls = buildS(1, 
  351.       Construct(P_VARDECL, 3, BSD("l", 0), builtinInteger, NN));
  352.     opDecls = F_NewNode(T_SEQUENCE, 9);
  353.     opDecls->nChildren += 9;
  354.     for (i = 0; i < 6; i++) {
  355.       opDecls->b.children[i] = Construct(P_OPDEF, 2,
  356.         copySig(opSigSeq->b.children[i]),
  357.         buildBlock(
  358.           BSR("r", 0),
  359.           buildInvocation(
  360.         BSR("l", 0),
  361.         opSigSeq->b.children[i]->b.opsig.name,
  362.         1,
  363.         buildInvocation(
  364.           BSR("p", 0),
  365.           BON("ord", -1), 
  366.           0)), 
  367.         NN));
  368.     }
  369. /* build succ */
  370.     s1 = Construct(P_ASSERTSTAT, 1,
  371.       buildInvocation(
  372.         BSR("l", 0),
  373.         BON("<", -1),
  374.         1,
  375.         buildIntegerLiteral(numFields-1)));
  376.     s2 = Construct(P_ASSIGNSTAT, 3,
  377.       buildS(1, BSR("r", 0)),
  378.       (NodePtr) OASSIGN,
  379.       buildS(1, buildInvocation(
  380.         BSR("enum", 0),
  381.         BON("create", -1),
  382.         1,
  383.         buildInvocation(
  384.           BSR("l", 0),
  385.           BON("+", -1),
  386.           1,
  387.           buildIntegerLiteral(1)))));
  388.     block = Construct(P_BLOCK, 3, buildS(2, s1, s2), NN, NN);
  389.     opDecls->b.children[6]= Construct(P_OPDEF, 2,
  390.       copySig(opSigSeq->b.children[6]),
  391.       block);
  392. /* build pred */
  393.     s1 = Construct(P_ASSERTSTAT, 1,
  394.       buildInvocation(
  395.         BSR("l", 0),
  396.         BON(">", -1),
  397.         1,
  398.         buildIntegerLiteral(0)));
  399.     s2 = Construct(P_ASSIGNSTAT, 3,
  400.       buildS(1, BSR("r", 0)),
  401.       (NodePtr) OASSIGN,
  402.       buildS(1, buildInvocation(
  403.         BSR("enum", 0),
  404.         BON("create", -1),
  405.         1,
  406.         buildInvocation(
  407.           BSR("l", 0),
  408.           BON("-", -1),
  409.           1,
  410.           buildIntegerLiteral(1)))));
  411.     block = Construct(P_BLOCK, 3, buildS(2, s1, s2), NN, NN);
  412.     opDecls->b.children[7]= Construct(P_OPDEF, 2,
  413.       copySig(opSigSeq->b.children[7]),
  414.       block);
  415. /* build ord */
  416.     opDecls->b.children[8]= Construct(P_OPDEF, 2,
  417.       copySig(opSigSeq->b.children[8]),
  418.       buildBlock(BSR("r", 0), BSR("l", 0), NN));
  419.  
  420.     monitorO->b.monitor.decls = varDecls;
  421.     monitorO->b.monitor.ops = opDecls;
  422.     monitorO->b.monitor.init = Construct(P_INITDEF, 1,
  423.       buildBlock(BSR("l", 0), BSR("p", 0), NN));
  424.     monitorO->b.monitor.recovery = NN;
  425.     monitorO->b.monitor.mayBeElided = TRUE;
  426.     instanceO->b.oblit.monitor = monitorO;
  427.     instanceO->b.oblit.ops = NN;
  428.     instanceO->b.oblit.process = NN;
  429.  
  430.     typeO->b.oblit.ops->b.children[1] = Construct(P_OPDEF, 2, 
  431.       createSig,
  432.       buildBlock(BSR("r", 0), instanceO, NN));
  433. /* first operation on type */
  434.     sig = buildSignature(BON("first", -1), NN, BSR("instanceAT", -1), NN);
  435.     sig->b.opsig.isFunction = TRUE;
  436.     typeO->b.oblit.ops->b.children[2] = Construct(P_OPDEF, 2,
  437.       sig,
  438.       buildBlock(
  439.         BSR("r", 0),
  440.         buildInvocation(
  441.           Construct(P_SELFLIT, 0),
  442.           BON("create", 0),
  443.           1,
  444.           buildIntegerLiteral(0)),
  445.         NN));
  446. /* last operation on type */
  447.     sig = buildSignature(BON("last", -1), NN, BSR("instanceAT", -1), NN);
  448.     sig->b.opsig.isFunction = TRUE;
  449.     typeO->b.oblit.ops->b.children[3] = Construct(P_OPDEF, 2,
  450.       sig,
  451.       buildBlock(
  452.         BSR("r", 0),
  453.         buildInvocation(
  454.           Construct(P_SELFLIT, 0),
  455.           BON("create", 0),
  456.           1,
  457.           buildIntegerLiteral(numFields - 1)),
  458.         NN));
  459. /* all the other creation operations on the type */
  460.     for (i = 0; i < numFields; i++) {
  461.       thisField = p->b.enumlit.syms->b.children[i];
  462.       sig = buildSignature(
  463.         BON(Ident_Name(thisField->b.symdef.ident), -1),
  464.         NN,
  465.         BSR("instanceAT", -1),
  466.         NN);
  467.       sig->b.opsig.isFunction = TRUE;
  468.       typeO->b.oblit.ops->b.children[4+i] = Construct(
  469.         P_OPDEF,
  470.         2,
  471.         sig,
  472.         buildBlock(
  473.           BSR("r", 0),
  474.           buildInvocation(
  475.         Construct(P_SELFLIT, 0),
  476.         BON("create", 0),
  477.         1,
  478.         buildIntegerLiteral(i)),
  479.           NN));
  480.     }
  481.     typeO->b.oblit.process = NN;
  482.  
  483.     typeO->b.oblit.f.immutable = TRUE;
  484.     instanceO->b.oblit.f.immutable = TRUE;
  485.     *fNodePtr = typeO;
  486.     removeSugar(fNodePtr);
  487.     return;
  488.     /*break;*/
  489.       case P_UNIONLIT:
  490.     break;
  491.       case P_RECORDLIT:
  492.     isImmutable = p->b.recordlit.f.immutable;
  493.     factor = isImmutable ? 1 : 2;
  494.     typeO = F_NewNode(P_OBLIT, 10);
  495.     typeO->nChildren += 10;
  496.     typeO->b.oblit.sfname = buildString(currentFileName);
  497.     typeO->b.oblit.name = p->b.recordlit.name;
  498.     typeO->b.oblit.export = Construct(P_EXPORT, 2,
  499.       buildS(3, BON("getsignature", -1), BON("create", -1),BON("new", -1)),
  500.       NN);
  501.     /*
  502.     * Build the abstract type for the instances.
  503.     */
  504.     assert(p->b.recordlit.fields->tag == T_SEQUENCE);
  505.     numFields = p->b.recordlit.fields->nChildren;
  506.     opSigSeq = F_NewNode(T_SEQUENCE, factor * numFields);
  507.     opSigSeq->nChildren = factor * numFields;
  508.     for (i = 0; i < numFields; i++) {
  509.       thisField = p->b.recordlit.fields->b.children[i];
  510.       opSigSeq->b.children[factor * i] = buildSignature(
  511.         BON("get", thisField->b.vardecl.sym->b.symdef.ident),
  512.         NN /* trailer for args */,
  513.         thisField->b.vardecl.type,
  514.         NN /* trailer for results */);
  515.       opSigSeq->b.children[factor * i]->b.opsig.isFunction = TRUE;
  516.       if (! isImmutable) {
  517.         opSigSeq->b.children[factor * i + 1] = buildSignature(
  518.           BON("set", thisField->b.vardecl.sym->b.symdef.ident),
  519.           thisField->b.vardecl.type,
  520.           NN,
  521.           NN);
  522.         opSigSeq->b.children[factor*i+1]->b.opsig.isFunction = FALSE;
  523.       }
  524.     }
  525.     instanceAT = Construct(
  526.       P_ATLIT,
  527.       4,
  528.       NULL,
  529.       NULL,
  530.       BSD("instanceAT", -1),
  531.       opSigSeq);
  532.     instanceAT->b.atlit.f.immutable = isImmutable;
  533.     typeO->b.oblit.decls = buildS(1, Construct(P_CONSTDECL, 3,
  534.       BSD("instanceAT", -1),
  535.       NN,
  536.       instanceAT));
  537.     typeO->b.oblit.monitor = NN;
  538.     /*
  539.     * The operations on the type.
  540.     */
  541.     typeO->b.oblit.ops = buildS(3, NN, NN);
  542.     od = Construct(P_OPDEF, 2, 
  543.       buildSignature(BON("getsignature", -1), NN, builtinPAT, NN),
  544.       buildBlock(BSR("r", 0), BSR("instanceAT", -1), NN));
  545.     od->b.opdef.sig->b.opsig.isFunction = TRUE;
  546.     typeO->b.oblit.ops->b.children[0] = od;
  547.     /* build "new" */
  548.     /* use r */
  549.     r = p->b.recordlit.fields;
  550.     argvec = (NodePtr *) 
  551.       malloc((unsigned)(sizeof(NodePtr)*(r->nChildren)));
  552.     for (i = 0; i < r->nChildren; i++) {
  553.       argvec[i] = Construct(P_NILLIT, 0);
  554.     }
  555.     od = Construct(P_OPDEF, 2,
  556.       buildSignature(BON("new", -1), NN, BSR("instanceAT", -1), NN),
  557.       buildBlock(BSR("r", 0),
  558.         _buildInvocation(
  559.           Construct(P_SELFLIT, 0),
  560.           BON("create", 0),
  561.           r->nChildren,
  562.           argvec),
  563.         NN));
  564.     typeO->b.oblit.ops->b.children[2] = od;
  565.     /* end use r */
  566.     /* build "create" */
  567.     /* use r */
  568.     r = p->b.recordlit.fields;
  569.     argvec = (NodePtr *) 
  570.       malloc((unsigned)(sizeof(NodePtr)*(r->nChildren + 3)));
  571.     for (i = 0; i < r->nChildren; i++) {
  572.       argvec[i] = r->b.children[i]->b.vardecl.type;
  573.     }
  574.     /* end use r */
  575.     argvec[i++] = 0;
  576.     argvec[i++] = BSR("instanceAT", -1);
  577.     argvec[i++] = 0;
  578.     createSig = _buildSignature(BON("create", -1), argvec);
  579.     free((char *)argvec);
  580.  
  581. /* build the instanceO. */
  582.     instanceO = F_NewNode(P_OBLIT, 10);
  583.     instanceO->nChildren += 10;
  584.     instanceO->b.oblit.sfname = buildString(currentFileName);
  585.     instanceO->b.oblit.name = 
  586.       buildComplicatedSymbol(P_SYMDEF, 
  587.         "a",
  588.         typeO->b.oblit.name->b.symdef.ident,
  589.         "record");
  590.     exportSeq = F_NewNode(T_SEQUENCE, numFields * factor);
  591.     exportSeq->nChildren = numFields * factor;
  592.     instanceO->b.oblit.export = Construct(P_EXPORT, 2, exportSeq, NN);
  593.     instanceO->b.oblit.decls = NN;
  594.     monitorO = F_NewNode(P_MONITOR, 4);
  595.     monitorO->nChildren += 4;
  596.     varDecls = F_NewNode(T_SEQUENCE, numFields);
  597.     varDecls->nChildren = numFields;
  598.     opDecls = F_NewNode(T_SEQUENCE, factor * numFields);
  599.     opDecls->nChildren = factor * numFields;
  600.     for (i = 0; i < numFields; i++) {
  601.       thisField = p->b.recordlit.fields->b.children[i];
  602.       exportSeq->b.children[factor*i+0] =
  603.         opSigSeq->b.children[factor*i+0]->b.opsig.name;
  604.       if (!isImmutable) {
  605.         exportSeq->b.children[factor*i+1] =
  606.           opSigSeq->b.children[factor*i+1]->b.opsig.name;
  607.       }
  608.       varDecls->b.children[i] = Construct(P_VARDECL, 3,
  609.         BSD("l", i),
  610.         thisField->b.vardecl.type,
  611.         Construct(P_SYMREF, 0));
  612.       varDecls->b.children[i]->b.vardecl.isAttached = thisField->b.vardecl.isAttached;
  613.       varDecls->b.children[i]->b.vardecl.value->b.symref.ident =
  614.         createSig->b.opsig.params->b.children[i]->b.param.sym
  615.           ->b.symdef.ident;
  616.       opDecls->b.children[factor*i+0] = Construct(P_OPDEF, 2,
  617.         copySig(opSigSeq->b.children[factor*i+0]),
  618.         buildBlock(BSR("r", 0), BSR("l", i), NN));
  619.       if (!isImmutable) {
  620.         opDecls->b.children[factor*i+1] = Construct(P_OPDEF, 2,
  621.           copySig(opSigSeq->b.children[factor*i+1]),
  622.           buildBlock(BSR("l", i), BSR("p", 0), NN));
  623.       }
  624.     }
  625.     monitorO->b.monitor.decls = varDecls;
  626.     monitorO->b.monitor.ops = opDecls;
  627.     monitorO->b.monitor.mayBeElided = TRUE;
  628.     monitorO->b.monitor.init = NN;
  629.     monitorO->b.monitor.recovery = NN;
  630.     instanceO->b.oblit.monitor = monitorO;
  631.     instanceO->b.oblit.ops = NN;
  632.     instanceO->b.oblit.process = NN;
  633.     typeO->b.oblit.ops->b.children[1] = Construct(P_OPDEF, 2, 
  634.       createSig,
  635.       buildBlock(BSR("r", 0), instanceO, NN));
  636.     typeO->b.oblit.process = NN;
  637.     typeO->b.oblit.f.immutable = TRUE;
  638.     instanceO->b.oblit.f.immutable = isImmutable;
  639.     instanceO->b.oblit.f.resultsDependOnlyOnArgs = TRUE;
  640.     *fNodePtr = typeO;
  641.     removeSugar(fNodePtr);
  642.     return;
  643.     /*break;*/
  644.       default:
  645.     break;
  646.     }
  647.     p = *fNodePtr;
  648.     for (i = p->firstChild; i < p->nChildren; i++) {
  649.       removeSugar(&(p->b.children[i]));
  650.     }
  651.   }
  652. }
  653.  
  654. /*VARARGS2*/
  655. static NodePtr buildS(n, first)
  656. int n;
  657. NodePtr first;
  658. {
  659.   return(_buildS(n, &first));
  660. }
  661.  
  662. static NodePtr _buildS(n, args)
  663. register int n;
  664. register NodePtr *args;
  665. {
  666.   register NodePtr p;
  667.   register int i;
  668.   if (n == 0) return(NN);
  669.   p = F_NewNode(T_SEQUENCE, n);
  670.   p->nChildren = n;
  671.   for (i = 0; i < n; i++) p->b.children[i] = args[i];
  672.   return(p);
  673. }
  674.  
  675. static void fixParams(p, prefix)
  676. register NodePtr p;
  677. char *prefix;
  678. {
  679.   register int i;
  680.   register NodePtr r;
  681.  
  682.   if (p == NN) return;
  683.   for (i = 0; i < p->nChildren; i++) {
  684.     r = BSD(prefix, i);
  685.     r = Construct(P_PARAM, 3, r, p->b.children[i], NULL);
  686.     r->b.param.move = FALSE;
  687.     p->b.children[i] = r;
  688.   }
  689. }
  690.  
  691. /*VARARGS2*/
  692. static NodePtr buildSignature(opName, first)
  693. NodePtr opName;
  694. NodePtr first;
  695. {
  696.   return (_buildSignature(opName, &first));
  697. }
  698.  
  699. static NodePtr _buildSignature(opName, args)
  700. NodePtr opName;
  701. NodePtr *args;
  702. {
  703.   NodePtr result;
  704.   NodePtr *params, *results;
  705.   int nParams, nResults;
  706.   register int i;
  707.   i = 0;
  708.   params = &args[i];
  709.   nParams = 0;
  710.   while (args[i]) {
  711.     nParams++;
  712.     i++;
  713.   }
  714.   i++;
  715.   results = &args[i];
  716.   nResults = 0;
  717.   while (args[i]) {
  718.     nResults++;
  719.     i++;
  720.   }
  721.   result = Construct(P_OPSIG, 4,
  722.     opName,
  723.     _buildS(nParams, params),
  724.     _buildS(nResults, results),
  725.     NN);
  726.   fixParams(result->b.opsig.params, "p");
  727.   fixParams(result->b.opsig.results, "r");
  728.   return (result);
  729. }
  730.  
  731. /*VARARGS1*/
  732. static NodePtr buildBlock(first)
  733. NodePtr first;
  734. {
  735.   return(_buildBlock(&first));
  736. }
  737.  
  738. static NodePtr _buildBlock(args)
  739. NodePtr *args;
  740. {
  741.   register NodePtr result;
  742.   int nStatements = 0;
  743.   register int i;
  744.  
  745.   for (i = 0; args[i] != NN; i += 2) nStatements ++;
  746.   result = F_NewNode(T_SEQUENCE, nStatements);
  747.   result->nChildren = nStatements;
  748.   for (i = 0; i < nStatements; i++) {
  749.     result->b.children[i] = Construct(P_ASSIGNSTAT, 3,
  750.       buildS(1, args[2*i+0]),
  751.       (NodePtr) OASSIGN,
  752.       buildS(1, args[2*i+1]));
  753.   }
  754.   result = Construct(P_BLOCK, 3, result, NN, NN);
  755.   return(result);
  756. }
  757.